Freelog 22/freelog 22.iso/Prog/Djgpp/GPC2952B.ZIP/doc/gpc/demos/crtdemo.pas

Pascal/Delphi Source File | 2001-02-08 | 34.1 KB | 1,089 lines

{
GPC demo program for the CRT unit.

Copyright (C) 1999-2001 Free Software Foundation, Inc.

Author: Frank Heckenbach <[e-mail]>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation, version 2.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

As a special exception, if you incorporate even large parts of the
code of this demo program into another program with substantially
different functionality, this does not cause the other program to
be covered by the GNU General Public License. This exception does
not however invalidate any other reasons why it might be covered
by the GNU General Public License.
}

program CRTDemo;

uses GPC, CRT;

type
  TFrameChars = array [1 .. 8] of Char;
  TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);

const
  SingleFrame : TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
  DoubleFrame : TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);

var
  ScrollState : Boolean = True;
  SimulateBlockCursorKind : TSimulateBlockCursorKind = bc_None;
  CursorShape : TCursorShape = CursorNormal;
  MainPanel : TPanel;
  OrigScreenSize : TPoint;

procedure FrameWin (const Title : String; const Frame : TFrameChars; TitleInverse : Boolean);
var
  w, h, y, Color : Integer;
  Attr : TTextAttr;
begin
  HideCursor;
  SetPCCharSet (True);
  ClrScr;
  w := GetXMax;
  h := GetYMax;
  WriteCharAt (1, 1, 1,     Frame [1], TextAttr);
  WriteCharAt (2, 1, w - 2, Frame [2], TextAttr);
  WriteCharAt (w, 1, 1,     Frame [3], TextAttr);
  for y := 2 to h - 1 do
    begin
      WriteCharAt (1, y, 1, Frame [4], TextAttr);
      WriteCharAt (w, y, 1, Frame [5], TextAttr)
    end;
  WriteCharAt (1, h, 1,     Frame [6], TextAttr);
  WriteCharAt (2, h, w - 2, Frame [7], TextAttr);
  WriteCharAt (w, h, 1,     Frame [8], TextAttr);
  SetPCCharSet (False);
  Attr := TextAttr;
  if TitleInverse then
    begin
      Color := GetTextColor;
      TextColor (GetTextBackground);
      TextBackground (Color)
    end;
  WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
  TextAttr := Attr
end;

function GetKey (TimeOut : Integer) = Key : TKey; forward;

procedure ClosePopUpWindow;
begin
  PanelDelete (GetActivePanel);
  PanelDelete (GetActivePanel)
end;

function PopUpConfirm (XSize, YSize : Integer; const Msg : String) : Boolean;
var
  ax, ay : Integer;
  Key : TKey;
begin
  repeat
    with ScreenSize do
      begin
        ax := (X - XSize - 4) div 2 + 1;
        ay := (Y - YSize - 4) div 2 + 1
      end;
    PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False);
    TextBackground (Black);
    TextColor (Yellow);
    SetControlChars (True);
    FrameWin ('', DoubleFrame, False);
    NormalCursor;
    PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
    ClrScr;
    Write (Msg);
    Key := GetKey (- 1);
    if Key = kbScreenSizeChanged then ClosePopUpWindow
  until Key <> kbScreenSizeChanged;
  PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
end;

procedure MainDraw;
begin
  Writeln ('3, F3  : Open a window');
  Writeln ('4, F4  : Close a window');
  Writeln ('5, F5  : Previous window');
  Writeln ('6, F6  : Next window');
  Writeln ('7, F7  : Move window');
  Writeln ('8, F8  : Resize window');
  Write   ('q, Esc : Quit')
end;

procedure StatusDraw;
const
  YesNo : array [Boolean] of String [3] = ('No', 'Yes');
  SimulateBlockCursorIDs : array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static');
  CursorShapeIDs : array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
begin
  Writeln ('You can change some of the following');
  Writeln ('settings  by pressing the key  shown');
  Writeln ('in parentheses. Naturally, color and');
  Writeln ('changing the cursor  shape or screen');
  Writeln ('size does not work on all terminals.');
  Writeln;
  Writeln ('XCurses version:          ', YesNo [XCRT]);
  Writeln ('CRTSavePreviousScreen:    ', YesNo [CRTSavePreviousScreenWorks]);
  Writeln ('(M)onochrome:             ', YesNo [IsMonochrome]);
  with ScreenSize do
    begin
      Writeln ('Screen (C)olumns:         ', X);
      Writeln ('Screen (L)ines:           ', Y);
      Writeln ('(R)estore screen size');
    end;
  Writeln ('(B)reak checking:         ', YesNo [CheckBreak]);
  Writeln ('(S)crolling:              ', YesNo [ScrollState]);
  Writeln ('S(i)mulated block cursor: ', SimulateBlockCursorIDs [SimulateBlockCursorKind]);
  Write   ('C(u)rsor shape:           ', CursorShapeIDs [CursorShape]);
  GotoXY (36, WhereY)
end;

procedure RedrawAll; forward;
procedure CheckScreenSize; forward;

procedure StatusKey (Key : TKey);
var NewSize : TPoint;
begin
  case LoCase (Key2Char (Key)) of
    'm' : begin
            SetMonochrome (not IsMonochrome);
            RedrawAll
          end;
    'c' : with ScreenSize do
            begin
              if X > 40 then
                NewSize.X := 40
              else
                NewSize.X := 80;
              if Y > 25 then
                NewSize.Y := 50
              else
                NewSize.Y := 25;
              SetScreenSize (NewSize.X, NewSize.Y);
              CheckScreenSize
            end;
    'l' : with ScreenSize do
            begin
              if X > 40 then
                NewSize.X := 80
              else
                NewSize.X := 40;
              if Y > 25 then
                NewSize.Y := 25
              else
                NewSize.Y := 50;
              SetScreenSize (NewSize.X, NewSize.Y);
              CheckScreenSize
            end;
    'r' : begin
            SetScreenSize (OrigScreenSize.X, OrigScreenSize.Y);
            CheckScreenSize
          end;
    'b' : CheckBreak := not CheckBreak;
    's' : ScrollState := not ScrollState;
    'i' : if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
            SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
          else
            Inc (SimulateBlockCursorKind);
    'u' : begin
            case CursorShape of
              CursorNormal : CursorShape := CursorBlock;
              CursorFat,
              CursorBlock  : CursorShape := CursorHidden;
              else           CursorShape := CursorNormal
            end
          end;
  end;
  ClrScr;
  StatusDraw
end;

procedure TextAttrDemo;
const HexDigits : array [0 .. $f] of Char = '0123456789ABCDEF';
var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3 : Integer;
begin
  GetWindow (x1, y1, x2, y2);
  Window (x1 - 1, y1, x2, y2);
  TextColor (White);
  TextBackground (Blue);
  ClrScr;
  SetScroll (False);
  Fill := GetXMax - 32;
  for y := 1 to GetYMax do
    begin
      GotoXY (1, y);
      b := (y - 1) mod 16;
      n1 := 0;
      for f := 0 to 15 do
        begin
          TextAttr := f + 16 * b;
          n2 := (Fill * (1 + 2 * f) + 16) div 32;
          n3 := (Fill * (2 + 2 * f) + 16) div 32;
          Write ('' : n2 - n1, HexDigits [b], HexDigits [f], '' : n3 - n2);
          n1 := n3
        end
    end
end;

procedure CharSetDemo (UsePCCharSet : Boolean);
var h, l, y, x1, y1, x2, y2, Fill, n1, n2 : Integer;
begin
  GetWindow (x1, y1, x2, y2);
  Window (x1 - 1, y1, x2, y2);
  ClrScr;
  SetScroll (False);
  SetPCCharSet (UsePCCharSet);
  SetControlChars (False);
  Fill := GetXMax - 35;
  for y := 1 to GetYMax do
    begin
      GotoXY (1, y);
      h := (y - 2) mod 16;
      n1 := (Fill + 9) div 18;
      if y = 1 then
        Write ('' : 3 + n1)
      else
        Write (16 * h : 3 + n1);
      for l := 0 to 15 do
        begin
          n2 := (Fill * (2 + l) + 9) div 18;
          if y = 1 then
            Write ('' : n2 - n1, l : 2)
          else
            Write ('' : n2 - n1 + 1, Chr (16 * h + l));
          n1 := n2
        end
    end
end;

procedure NormalCharSetDemo;
begin
  CharSetDemo (False)
end;

procedure PCCharSetDemo;
begin
  CharSetDemo (True)
end;

procedure FKeyDemoDraw;
var x1, y1, x2, y2 : Integer;
begin
  GetWindow (x1, y1, x2, y2);
  Window (x1, y1, x2 - 1, y2);
  ClrScr;
  SetScroll (False);
  Writeln ('You can type the following keys');
  Writeln ('(function keys if present on the');
  Writeln ('terminal, letters as alternatives):');
  Writeln ('S, Left      : left (wrap-around)');
  Writeln ('D, Right     : right (wrap-around)');
  Writeln ('E, Up        : up (wrap-around)');
  Writeln ('X, Down      : down (wrap-around)');
  Writeln ('A, Home      : go to first column');
  Writeln ('F, End       : go to last column');
  Writeln ('R, Page Up   : go to first line');
  Writeln ('C, Page Down : go to last line');
  Writeln ('Y, Ctrl-PgUp : first column and line');
  GotoXY (1, 13);
  Writeln ('B, Ctrl-PgDn : last column and line');
  Writeln ('Z, Ctrl-Home : clear screen');
  Writeln ('N, Ctrl-End  : clear to end of line');
  Writeln ('V, Insert    : insert a line');
  Writeln ('T, Delete    : delete a line');
  Writeln ('#            : beep');
  Writeln ('*            : flash');
  Writeln ('Tab, Enter, Backspace, other normal');
  Writeln ('  characters : write text')
end;

procedure FKeyDemoKey (Key : TKey);
const TabSize = 8;
var
  Ch : Char;
  NewX : Integer;
begin
  case LoCaseKey (Key) of
    Ord ('s'), kbLeft     : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY);
    Ord ('d'), kbRight    : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY);
    Ord ('e'), kbUp       : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1);
    Ord ('x'), kbDown     : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1);
    Ord ('a'), kbHome     : Write (chCR);
    Ord ('f'), kbEnd      : GotoXY (GetXMax, WhereY);
    Ord ('r'), kbPgUp     : GotoXY (WhereX, 1);
    Ord ('c'), kbPgDn     : GotoXY (WhereX, GetYMax);
    Ord ('y'), kbCtrlPgUp : GotoXY (1, 1);
    Ord ('b'), kbCtrlPgDn : GotoXY (GetXMax, GetYMax);
    Ord ('z'), kbCtrlHome : ClrScr;
    Ord ('n'), kbCtrlEnd  : ClrEOL;
    Ord ('v'), kbIns      : InsLine;
    Ord ('t'), kbDel      : DelLine;
    Ord ('#')             : Beep;
    Ord ('*')             : Flash;
    kbTab                 : begin
                              NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
                              if NewX <= GetXMax then GotoXY (NewX, WhereY) else Writeln
                            end;
    kbCR                  : Writeln;
    kbBkSp                : Write (chBkSp, ' ', chBkSp);
    else                    Ch := Key2Char (Key);
                            if Ch <> #0 then Write (Ch)
  end
end;

procedure KeyDemoDraw;
begin
  Writeln ('Press some keys...')
end;

procedure KeyDemoKey (Key : TKey);
var Ch : Char;
begin
  Ch := Key2Char (Key);
  if Ch <> #0 then
    begin
      Write ('Normal key');
      if Ch in [' ' .. #126] then Write (' `', Ch, '''');
      Writeln (', ASCII #', Ord (Ch))
    end
  else
    Writeln ('Special key ', Ord (Key2Scan (Key)))
end;

procedure IOSelectPeriodical;
var
  CurrentTime : TimeStamp;
  s : String (8);
  i : Integer;
begin
  GetTimeStamp (CurrentTime);
  with CurrentTime do
    WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2);
  for i := 1 to Length (s) do
    if s [i] = ' ' then s [i] := '0';
  GotoXY (1, 12);
  Write ('The time is: ', s)
end;

procedure IOSelectDraw;
begin
  Writeln ('IOSelect is a way to handle I/O from');
  Writeln ('or to several places simultaneously,');
  Writeln ('without  having  to use  threads  or');
  Writeln ('signal/interrupt  handlers  or waste');
  Writeln ('CPU time with busy waiting.');
  Writeln;
  Writeln ('This demo  shows how  IOSelect works');
  Writeln ('in connection with CRT.  It displays');
  Writeln ('a clock,  but still  reacts  to user');
  Writeln ('input immediately.');
  IOSelectPeriodical
end;

procedure ModifierPeriodical;
const
  Pressed : array [Boolean] of String [8] = ('Released', 'Pressed');
  ModifierNames : array [1 .. 7] of record
    Modifier : Integer;
    Name     : String (17)
  end =
   ((shLeftShift,  'Left Shift'),
    (shRightShift, 'Right Shift'),
    (shLeftCtrl,   'Left Control'),
    (shRightCtrl,  'Right Control'),
    (shAlt,        'Alt (left)'),
    (shAltGr,      'AltGr (right Alt)'),
    (shExtra,      'Extra'));
var
  ShiftState, i : Integer;
begin
  ShiftState := GetShiftState;
  for i := 1 to 7 do
    with ModifierNames [i] do
      begin
        GotoXY (1, 4 + i);
        ClrEOL;
        Write (Name, ':');
        GotoXY (20, WhereY);
        Write (Pressed [ShiftState and Modifier <> 0])
      end
end;

procedure ModifierDraw;
begin
  Writeln ('Modifier keys (NOTE: only');
  Writeln ('available on some systems;');
  Writeln ('X11: only after key press):');
  ModifierPeriodical
end;

procedure ChecksDraw;
begin
  Writeln ('(O)S shell');
  Writeln ('OS shell with (C)learing');
  Writeln ('(R)efresh check');
  Write   ('(S)ound check')
end;

procedure ChecksKey (Key : TKey);
var
  i, j : Integer;
  Dummy : volatile Real;

  procedure DoOSShell;
  var
    Result : Integer;
    Shell : TString;
    Dummy : TKey;
  begin
    Shell := GetShellPath (null);
    {$I-}
    Result := Execute (Shell);
    {$I+}
    if (InOutRes <> 0) or (Result <> 0) then
      begin
        ClrScr;
        if InOutRes <> 0 then
          Writeln (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
        else
          Writeln ('`', Shell, ''' returned status ', Result, '.');
        Write ('Any key to continue.');
        BlockCursor;
        Dummy := GetKey (- 1)
      end
  end;

begin
  case LoCase (Key2Char (Key)) of
    'o' : begin
            if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine +
                                     'CRTDemo is running  in its own (GUI)' + NewLine +
                                     'window,  the shell  will run  on the' + NewLine +
                                     'same screen as CRTDemo  which is not' + NewLine +
                                     'cleared before the shell is started.' + NewLine +
                                     'If possible, the screen contents are' + NewLine +
                                     'restored to the state before CRTDemo' + NewLine +
                                     'was started. After leaving the shell' + NewLine +
                                     'in the usual way (usually  by enter-' + NewLine +
                                     'ing  `exit''), you will  get back to' + NewLine +
                                     'the demo.  <ESC> to abort, any other' + NewLine +
                                     'key to start.') then
              begin
                RestoreTerminal (True);
                DoOSShell
              end;
            ClosePopUpWindow
          end;
    'c' : begin
            if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine +
                                    'CRTDemo is running in  its own (GUI)' + NewLine +
                                    'window, the screen  will be cleared,' + NewLine +
                                    'and the cursor will be  moved to the' + NewLine +
                                    'top  before  the  shell  is started.' + NewLine +
                                    'After leaving the shell in the usual' + NewLine +
                                    'way  (usually  by entering  `exit''),' + NewLine +
                                    'you will get back to the demo. <ESC>' + NewLine +
                                    'to abort, any other key to start.') then
              begin
                RestoreTerminalClearCRT;
                DoOSShell
              end;
            ClosePopUpWindow
          end;
    'r' : begin
            if PopUpConfirm (36, 11, 'The program will  now get  busy with' + NewLine +
                                     'some  dummy  computations.  However,' + NewLine +
                                     'CRT output in  the form of dots will' + NewLine +
                                     'still appear continuously one by one' + NewLine +
                                     '(rather than the  whole line at once' + NewLine +
                                     'in the end). While running, the test' + NewLine +
                                     'cannot  be  interrupted.   <ESC>  to' + NewLine +
                                     'abort, any other key to start.') then
              begin
                SetCRTUpdate (UpdateRegularly);
                BlockCursor;
                Writeln;
                Writeln;
                for i := 1 to GetXMax - 2 do
                  begin
                    Write ('.');
                    for j := 1 to 400000 do Dummy := Random
                  end;
                SetCRTUpdate (UpdateInput);
                Writeln;
                Write ('Press any key.');
                Dummy := GetKey (- 1)
              end;
            ClosePopUpWindow
          end;
    's' : begin
            if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine +
                                    'supported  (otherwise there will' + NewLine +
                                    'just be a short pause). <ESC> to' + NewLine +
                                    'abort, any other key to start.') then
              begin
                BlockCursor;
                for i := 0 to 7 do
                  begin
                    Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
                    if GetKey (400000) in [kbEsc, kbAltEsc] then Break
                  end;
                NoSound
              end;
            ClosePopUpWindow
          end;
  end
end;

type
  PWindowList = ^TWindowList;
  TWindowList = record
    Next, Prev : PWindowList;
    Panel, FramePanel : TPanel;
    WindowType : Integer;
    x1, y1, xs, ys : Integer;
    State : (ws_None, ws_Moving, ws_Resizing);
  end;

  TKeyProc = procedure (Key : TKey);
  TProcedure = procedure;

const
  MenuNameLength = 16;
  WindowTypes  : array [0 .. 9] of record
    DrawProc,
    PeriodicalProc : procedure;
    KeyProc        : TKeyProc;
    Name           : String (MenuNameLength);
    Color,
    Background,
    MinSizeX,
    MinSizeY,
    PrefSizeX,
    PrefSizeY      : Integer;
    RedrawAlways,
    WantCursor     : Boolean
  end =
  ((MainDraw         , nil               , nil        , 'CRT Demo'        , LightGreen, Blue     , 26,  7,  0,  0, False, False),
   (StatusDraw       , nil               , StatusKey  , 'Status'          , White     , Red      , 38, 16,  0,  0, True,  True),
   (TextAttrDemo     , nil               , nil        , 'Text Attributes' , White     , Blue     , 32, 16, 64, 16, False, False),
   (NormalCharSetDemo, nil               , nil        , 'Character Set'   , Black     , Green    , 35, 17, 53, 17, False, False),
   (PCCharSetDemo    , nil               , nil        , 'PC Character Set', Black     , Brown    , 35, 17, 53, 17, False, False),
   (KeyDemoDraw      , nil               , KeyDemoKey , 'Keys'            , Blue      , LightGray, 29,  5, -1, -1, False, True),
   (FKeyDemoDraw     , nil               , FKeyDemoKey, 'Function Keys'   , Blue      , LightGray, 38, 22, -1, -1, False, True),
   (ModifierDraw     , ModifierPeriodical, nil        , 'Modifier Keys'   , Black     , Cyan     , 29, 11,  0,  0, True,  False),
   (IOSelectDraw     , IOSelectPeriodical, nil        , 'IOSelect Demo'   , White     , Magenta  , 38, 12,  0,  0, False, False),
   (ChecksDraw       , nil               , ChecksKey  , 'Various Checks'  , Black     , Red      , 26,  4,  0,  0, False, False));

  MenuMax = High (WindowTypes);
  MenuXSize = MenuNameLength + 4;
  MenuYSize = MenuMax + 2;

var
  WindowList : PWindowList = nil;

procedure RedrawFrame (p : PWindowList);
begin
  with p^, WindowTypes [WindowType] do
    begin
      PanelActivate (FramePanel);
      Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
      ClrScr;
      case State of
        ws_None     : if p = WindowList
                        then FrameWin (' ' + Name + ' ', DoubleFrame, True)
                        else FrameWin (' ' + Name + ' ', SingleFrame, False);
        ws_Moving   : FrameWin (' Move Window ', SingleFrame, True);
        ws_Resizing : FrameWin (' Resize Window ', SingleFrame, True);
      end
    end
end;

procedure DrawWindow (p : PWindowList);
begin
  with p^, WindowTypes [WindowType] do
    begin
      RedrawFrame (p);
      PanelActivate (Panel);
      Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
      ClrScr;
      DrawProc
    end
end;

procedure RedrawAll;
var
  LastPanel : TPanel;
  p : PWindowList;
  x2, y2 : Integer;
begin
  LastPanel := GetActivePanel;
  PanelActivate (MainPanel);
  TextBackground (Blue);
  ClrScr;
  p := WindowList;
  if p <> nil then
    repeat
      with p^ do
        begin
          PanelActivate (FramePanel);
          GetWindow (x1, y1, x2, y2); { updated automatically by CRT }
          xs := x2 - x1 + 1;
          ys := y2 - y1 + 1
        end;
      DrawWindow (p);
      p := p^.Next
    until p = WindowList;
  PanelActivate (LastPanel)
end;

procedure CheckScreenSize;
var
  LastPanel : TPanel;
  MinScreenSizeX, MinScreenSizeY, i : Integer;
begin
  LastPanel := GetActivePanel;
  PanelActivate (MainPanel);
  HideCursor;
  MinScreenSizeX := MenuXSize;
  MinScreenSizeY := MenuYSize;
  for i := Low (WindowTypes) to High (WindowTypes) do
    with WindowTypes [i] do
      begin
        MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
        MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
      end;
  with ScreenSize do
    begin
      Window (1, 1, X, Y);
      if (X < MinScreenSizeX) or (Y < MinScreenSizeY) then
        begin
          NormVideo;
          ClrScr;
          RestoreTerminal (True);
          Writeln (StdErr, 'Sorry, your screen is too small for this demo (', X, 'x', Y, ').');
          Writeln (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.');
          Halt (2)
        end
    end;
  PanelActivate (LastPanel);
  RedrawAll
end;

procedure Die; attribute (noreturn);
procedure Die;
begin
  NoSound;
  RestoreTerminalClearCRT;
  Writeln (StdErr, 'You''re trying to kill me. Since I have break checking turned off,');
  Writeln (StdErr, 'I''m not dying, but I''ll do you a favour and terminate now.');
  Halt (3)
end;

function GetKey (TimeOut : Integer) = Key : TKey;
var
  NeedSelect, SelectValue : Integer;
  SimulateBlockCursorCurrent : TSimulateBlockCursorKind;
  SelectInput : array [1 .. 1] of PAnyFile;
  NextSelectTime : static MicroSecondTimeType = 0;
  TimeOutTime : MicroSecondTimeType;
  LastPanel : TPanel;
  p : PWindowList;
begin
  LastPanel := GetActivePanel;
  if TimeOut < 0
    then TimeOutTime := High (TimeOutTime)
    else TimeOutTime := GetMicroSecondTime + TimeOut;
  NeedSelect := 0;
  if TimeOut >= 0 then
    Inc (NeedSelect);
  SimulateBlockCursorCurrent := SimulateBlockCursorKind;
  if SimulateBlockCursorCurrent <> bc_None then
    Inc (NeedSelect);
  p := WindowList;
  repeat
    if @WindowTypes [p^.WindowType].PeriodicalProc <> nil then
      Inc (NeedSelect);
    p := p^.Next
  until p = WindowList;
  p := WindowList;
  repeat
    with p^, WindowTypes [WindowType] do
      if RedrawAlways then
        begin
          PanelActivate (Panel);
          ClrScr;
          DrawProc
        end;
    p := p^.Next
  until p = WindowList;
  if NeedSelect <> 0 then
    repeat
      CRTUpdate;
      (*@@constarray1*)SelectInput [1] := ((*@@*)PAnyFile( @Input));
      SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
      if SelectValue = 0 then
        begin
          case SimulateBlockCursorCurrent of
            bc_None   : ;
            bc_Blink  : SimulateBlockCursor;
            bc_Static : begin
                          SimulateBlockCursor;
                          SimulateBlockCursorCurrent := bc_None;
                          Dec (NeedSelect)
                        end
          end;
          NextSelectTime := GetMicroSecondTime + 120000;
          p := WindowList;
          repeat
            with p^, WindowTypes [WindowType] do
              if @PeriodicalProc <> nil then
                begin
                  PanelActivate (Panel);
                  PeriodicalProc
                end;
            p := p^.Next
          until p = WindowList
        end;
    until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
  if NeedSelect = 0 then
    SelectValue := 1;
  if SelectValue = 0
    then Key := 0
    else Key := ReadKeyWord;
  if SimulateBlockCursorKind <> bc_None then
    SimulateBlockCursorOff;
  if IsDeadlySignal (Key) then Die;
  if Key = kbScreenSizeChanged then CheckScreenSize;
  PanelActivate (LastPanel)
end;

function Menu = n : Integer;
var
  i, ax, ay : Integer;
  Key : TKey;
  Done : Boolean;
begin
  n := 1;
  repeat
    with ScreenSize do
      begin
        ax := (X - MenuXSize) div 2 + 1;
        ay := (Y - MenuYSize) div 2 + 1
      end;
    PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False);
    SetControlChars (True);
    TextColor (Blue);
    TextBackground (LightGray);
    FrameWin (' Select Window ', DoubleFrame, True);
    IgnoreCursor;
    PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
    ClrScr;
    TextColor (Black);
    SetScroll (False);
    Done := False;
    repeat
      for i := 1 to MenuMax do
        begin
          GotoXY (1, i);
          if i = n
            then TextBackGround (Green)
            else TextBackGround (LightGray);
          ClrEOL;
          Write (' ', WindowTypes [i].Name);
          ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
        end;
      Key := GetKey (- 1);
      case LoCaseKey (Key) of
        kbUp                   : if n = 1 then n := MenuMax else Dec (n);
        kbDown                 : if n = MenuMax then n := 1 else Inc (n);
        kbHome,
        kbPgUp,
        kbCtrlPgUp,
        kbCtrlHome             : n := 1;
        kbEnd,
        kbPgDn,
        kbCtrlPgDn,
        kbCtrlEnd              : n := MenuMax;
        kbCR                   : Done := True;
        kbEsc, kbAltEsc        : begin
                                   n := - 1;
                                   Done := True
                                 end;
        Ord ('a') .. Ord ('z') : begin
                                   i := MenuMax;
                                   while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes [i].Name [1])) do Dec (i);
                                   if i > 0 then
                                     begin
                                       n := i;
                                       Done := True
                                     end
                                 end;
      end
    until Done or (Key = kbScreenSizeChanged);
    ClosePopUpWindow
  until Key <> kbScreenSizeChanged
end;

procedure NewWindow (WindowType, ax, ay : Integer);
var
  p, LastWindow : PWindowList;
  MaxX1, MaxY1 : Integer;
begin
  New (p);
  if WindowList = nil then
    begin
      p^.Prev := p;
      p^.Next := p
    end
  else
    begin
      p^.Prev := WindowList;
      p^.Next := WindowList^.Next;
      p^.Prev^.Next := p;
      p^.Next^.Prev := p;
    end;
  p^.WindowType := WindowType;
  with p^, WindowTypes [WindowType] do
    begin
      with ScreenSize do
        begin
          if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX;
          if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY;
          xs := Min (xs + 2, X);
          ys := Min (ys + 2, Y);
          MaxX1 := X - xs + 1;
          MaxY1 := Y - ys + 1;
          if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1);
          if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1);
          if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (X - x1 - xs + 2));
          if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (Y - y1 - ys + 2))
        end;
      State := ws_None;
      PanelNew (1, 1, 1, 1, False);
      FramePanel := GetActivePanel;
      SetControlChars (True);
      TextColor (Color);
      TextBackground (Background);
      PanelNew (1, 1, 1, 1, False);
      SetPCCharSet (False);
      Panel := GetActivePanel;
    end;
  LastWindow := WindowList;
  WindowList := p;
  if LastWindow <> nil then RedrawFrame (LastWindow);
  DrawWindow (p)
end;

procedure OpenWindow;
var WindowType : Integer;
begin
  WindowType := Menu;
  if WindowType >= 0 then NewWindow (WindowType, 0, 0)
end;

procedure NextWindow;
var LastWindow : PWindowList;
begin
  LastWindow := WindowList;
  WindowList := WindowList^.Next;
  PanelTop (WindowList^.FramePanel);
  PanelTop (WindowList^.Panel);
  RedrawFrame (LastWindow);
  RedrawFrame (WindowList)
end;

procedure PreviousWindow;
var LastWindow : PWindowList;
begin
  PanelMoveAbove (WindowList^.Panel, MainPanel);
  PanelMoveAbove (WindowList^.FramePanel, MainPanel);
  LastWindow := WindowList;
  WindowList := WindowList^.Prev;
  RedrawFrame (LastWindow);
  RedrawFrame (WindowList)
end;

procedure CloseWindow;
var p : PWindowList;
begin
  if WindowList^.WindowType <> 0 then
    begin
      p := WindowList;
      NextWindow;
      PanelDelete (p^.FramePanel);
      PanelDelete (p^.Panel);
      p^.Next^.Prev := p^.Prev;
      p^.Prev^.Next := p^.Next;
      Dispose (p)
    end
end;

procedure MoveWindow;
var Done, Changed : Boolean;
begin
  with WindowList^ do
    begin
      Done := False;
      Changed := True;
      State := ws_Moving;
      repeat
        if Changed then DrawWindow (WindowList);
        Changed := True;
        case LoCaseKey (GetKey (- 1)) of
          Ord ('s'), kbLeft     : if x1 > 1 then Dec (x1);
          Ord ('d'), kbRight    : if x1 + xs - 1 < ScreenSize.X then Inc (x1);
          Ord ('e'), kbUp       : if y1 > 1 then Dec (y1);
          Ord ('x'), kbDown     : if y1 + ys - 1 < ScreenSize.Y then Inc (y1);
          Ord ('a'), kbHome     : x1 := 1;
          Ord ('f'), kbEnd      : x1 := ScreenSize.X - xs + 1;
          Ord ('r'), kbPgUp     : y1 := 1;
          Ord ('c'), kbPgDn     : y1 := ScreenSize.Y - ys + 1;
          Ord ('y'), kbCtrlPgUp : begin
                                    x1 := 1;
                                    y1 := 1
                                  end;
          Ord ('b'), kbCtrlPgDn : with ScreenSize do
                                    begin
                                      x1 := X - xs + 1;
                                      y1 := Y - ys + 1
                                    end;
          kbCR,
          kbEsc, kbAltEsc       : Done := True;
          else                    Changed := False
        end
      until Done;
      State := ws_None;
      DrawWindow (WindowList)
    end
end;

procedure ResizeWindow;
var Done, Changed : Boolean;
begin
  with WindowList^, WindowTypes [WindowType] do
    begin
      Done := False;
      Changed := True;
      State := ws_Resizing;
      repeat
        if Changed then DrawWindow (WindowList);
        Changed := True;
        case LoCaseKey (GetKey (- 1)) of
          Ord ('s'), kbLeft     : if xs > MinSizeX + 2 then Dec (xs);
          Ord ('d'), kbRight    : if x1 + xs - 1 < ScreenSize.X then Inc (xs);
          Ord ('e'), kbUp       : if ys > MinSizeY + 2 then Dec (ys);
          Ord ('x'), kbDown     : if y1 + ys - 1 < ScreenSize.Y then Inc (ys);
          Ord ('a'), kbHome     : xs := MinSizeX + 2;
          Ord ('f'), kbEnd      : xs := ScreenSize.X - x1 + 1;
          Ord ('r'), kbPgUp     : ys := MinSizeY + 2;
          Ord ('c'), kbPgDn     : ys := ScreenSize.Y - y1 + 1;
          Ord ('y'), kbCtrlPgUp : begin
                                    xs := MinSizeX + 2;
                                    ys := MinSizeY + 2
                                  end;
          Ord ('b'), kbCtrlPgDn : with ScreenSize do
                                    begin
                                      xs := X - x1 + 1;
                                      ys := Y - y1 + 1
                                    end;
          kbCR,
          kbEsc, kbAltEsc       : Done := True;
          else                    Changed := False
        end
      until Done;
      State := ws_None;
      DrawWindow (WindowList)
    end
end;

procedure ActivateCursor;
begin
  with WindowList^, WindowTypes [WindowType] do
    begin
      PanelActivate (Panel);
      if WantCursor
        then SetCursorShape (CursorShape)
        else HideCursor
    end;
  SetScroll (ScrollState)
end;

var
  Key : TKey;
  ScreenShot, Done : Boolean;

begin
  ScreenShot := ParamStr (1) = '--screenshot';
  if ParamCount <> Ord (ScreenShot) then
    begin
      RestoreTerminal (True);
      Writeln (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
      Halt (1)
    end;
  CRTSavePreviousScreen;
  SetCRTUpdate (UpdateInput);
  MainPanel := GetActivePanel;
  CheckScreenSize;
  OrigScreenSize := ScreenSize;
  if ScreenShot then
    begin
      CursorShape := CursorBlock;
      NewWindow (6,      1,      1);
      NewWindow (2,      1, MaxInt);
      NewWindow (8, MaxInt,      1);
      NewWindow (5,      1,     27);
      KeyDemoKey (Ord ('f'));
      KeyDemoKey (246);
      KeyDemoKey (kbDown);
      NewWindow (3, MaxInt,     13);
      NewWindow (4, MaxInt,     31);
      NewWindow (7, MaxInt, MaxInt);
      NewWindow (9, MaxInt,     33);
      NewWindow (0,      1,      2);
      NewWindow (1,      1,     14);
      ActivateCursor;
      OpenWindow
    end
  else
    NewWindow (0, 3, 2);
  Done := False;
  repeat
    ActivateCursor;
    Key := GetKey (- 1);
    case LoCaseKey (Key) of
      Ord ('3'), kbF3  : OpenWindow;
      Ord ('4'), kbF4  : CloseWindow;
      Ord ('5'), kbF5  : PreviousWindow;
      Ord ('6'), kbF6  : NextWindow;
      Ord ('7'), kbF7  : MoveWindow;
      Ord ('8'), kbF8  : ResizeWindow;
      Ord ('q'), kbEsc,
      kbAltEsc :         Done := True;
      else
        if WindowList <> nil then
          with WindowList^, WindowTypes [WindowType] do
            if @KeyProc <> nil then
              begin
                TextColor (Color);
                TextBackground (Background);
                KeyProc (Key)
              end
    end
  until Done
end.